home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
WCTUNITS.ARJ
/
XGRAPH.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1991-07-31
|
9KB
|
297 lines
unit xgraph;
{ Written by William C. Thompson (wct@po.cwru.edu) - 1991 }
{ This unit was written for programs with heavy graphics usage.
There are a number of procedures to make graphics more bearable.
There are some procedures that do different drawings.
There are some procedures that can save/recall a screen image. }
{ Designer's Notes:
1. I have left some of the error checking, such as checking if
a file exists or not, out of the procedures. That is the
responsibility of the programmer. }
interface
uses graph,math;
type
imagebuffer=array[0..65534] of byte;
image=record
p: ^imagebuffer; { buffer for image }
size: word; { size of image }
end;
{ Instead of making p a generic pointer, I decided to make it
point to an array, so the contents of the array could be examined
more easily if the programmer so desired. }
var
europeanfont,complexfont,triplexscriptfont,scriptfont,simplefont:integer;
procedure setfillcolor(col:word);
procedure setfillpatt(pat: word);
procedure settextfont(font:word);
procedure settextsize(size:word);
procedure settextdir(dir:word);
procedure settextall(font,dir,size,hor,ver:word);
procedure xouttextxy(x1,y1:word; spacing:byte; s:string);
procedure ngon(cx,cy,sides: word; r,ang: real);
procedure fline(x1,y1,x2,y2:word; warp,pixres:real);
procedure fbranch(fn:string ; warp,pixres:real);
procedure frip(fn: string; warp,pixres: real);
procedure writeimage(fn:string; var im:image);
procedure readimage(fn:string; var im:image);
procedure grabimage(x1,y1,x2,y2:word; var im:image);
procedure showimage(x1,y1: word; var im:image; bitblt:word);
procedure killimage(var im:image);
implementation
procedure setfillcolor(col:word);
var
s: fillsettingstype;
begin
getfillsettings(s);
setfillstyle(s.pattern,col)
end;
procedure setfillpatt(pat: word);
var
s: fillsettingstype;
begin
getfillsettings(s);
setfillstyle(pat,s.color)
end;
procedure settextfont(font:word);
var
s: textsettingstype;
begin
gettextsettings(s);
settextstyle(font, s.direction, s.charsize)
end;
procedure settextsize(size:word);
var
s: textsettingstype;
begin
gettextsettings(s);
settextstyle(s.font, s.direction, size)
end;
procedure settextdir(dir:word);
var
s: textsettingstype;
begin
gettextsettings(s);
settextstyle(s.font, dir, s.charsize)
end;
procedure settextall(font,dir,size,hor,ver:word);
{ This is an EXTREMELY useful procedure to set all attributes of
graphics text settings. }
begin
settextstyle(font,dir,size);
settextjustify(hor,ver)
end;
procedure xouttextxy(x1,y1:word; spacing:byte; s:string);
{ Writing text in graphics mode can be very tedious. If you want
to write line after line after line, you have to type OutTextXY
about a million times and make quite a few mistakes doing it.
This is usually a big headache for me and makes me not want to
work on whatever I'm doing because it's so tedious. And thus
a procedure was born. What this procedure does is start writing
at (x1,y1) when it finds #13 in the string, it skips down Spacing
pixels and writes until the next #13, and so on. This lets you
change the spacing and move the text around more easily. You are
still limited to 255 characters, but it's still worth it. }
var
j: word;
p: byte;
begin
j:=y1;
while s<>'' do begin
{ find #13 in string }
p:=pos(#13,s);
if p>0 then begin
outtextxy(x1,j,copy(s,1,p-1));
delete(s,1,p);
j:=j+spacing
end
else begin
outtextxy(x1,j,s);
s:=''
end
end
end;
procedure ngon(cx,cy,sides: word; r,ang: real);
{ This procedure draws an n-sided polygon. (Cx,Cy) is the center.
Sides is obviously the number of sides. R is the distance from
the center to one of the elbows, and Ang is the angle of rotation.
Ang must be given in radians. }
var
i: word;
begin
for i:=0 to sides-1 do
line(round(cx+r*cos(i/sides*2*pi+ang-pi/2)),
round(cy+r*sin(i/sides*2*pi+ang-pi/2)),
round(cx+r*cos((i+1)/sides*2*pi+ang-pi/2)),
round(cy+r*sin((i+1)/sides*2*pi+ang-pi/2)));
end;
procedure fline(x1,y1,x2,y2:word; warp,pixres:real);
{ Generates a fractal line from (x1,y1) bent by Warp % such that no
two points are more than PixRes pixels apart. A higher Warp means
the line can deviate more. Caution: a Warp above 1.0 is not good }
var
d,ang:real;
x3,y3:word; { point of bend }
begin
d:=distance(x1,y1,x2,y2);
if d<=pixres then line(x1,y1,x2,y2)
else begin
ang:=random(65535)*9.5875262E-5; { generate [0,2 pi) }
x3:=round((x1+x2)/2+d/2*warp*sin(ang));
y3:=round((y1+y2)/2+d/2*warp*cos(ang));
fline(x1,y1,x3,y3,warp,pixres);
fline(x3,y3,x2,y2,warp,pixres)
end
end;
procedure fbranch(fn:string; warp,pixres:real);
{ reads a fractal branch file from disk and draws it with
parameters warp and pixres, as described in fline. There
is a maximum of MaxNodes nodes, but only as much space as
needed is allocated. Define a branch as follows:
number of nodes e.g. 5
list of each node's coordinates 100 100
...
list of connections from node to node 1 2
... }
const
maxnodes=1000;
type
nodelist=array[1..2*maxnodes] of word;
var
f: text;
i: word;
a,b: word; { node numbers }
pts: word; { number of nodes }
nl: ^nodelist; { pointer to list of nodes }
begin
assign(f,fn);
reset(f);
{ read in points }
readln(f,pts);
if pts<=maxnodes then getmem(nl,pts*4) else getmem(nl,maxnodes*4);
for i:=1 to pts do
if i<=maxnodes then readln(f,nl^[i*2-1],nl^[i*2]) else readln(f);
while not eof(f) do begin
readln(f,a,b);
if [a,b]*[1..pts]=[a,b] then
fline(nl^[a*2-1],nl^[a*2],nl^[b*2-1],nl^[b*2],warp,pixres)
end;
close(f);
end;
procedure frip(fn:string; warp,pixres:real);
{ Reads and draws a fractal rip (looks like a river)
A rip file is defined as follows:
List of coordinates to connect e.g. 100 100
150 120
160 180
...
This can be used to draw lakes, borders, etc.
There is no limit on the number of nodes. }
var
x1,y1,x2,y2: word;
f: text;
begin
assign(f,fn);
reset(f);
{ read first point }
readln(f,x1,y1);
while not eof(f) do begin
readln(f,x2,y2);
fline(x1,y1,x2,y2,warp,pixres);
x1:=x2;
y1:=y2
end;
close(f)
end;
procedure writeimage(fn:string; var im:image);
{ This procedure writes an image to the specified file. }
var
f: file;
p: pointer;
n: word;
begin
assign(f,fn);
rewrite(f,1); { objects are 1 byte large }
blockwrite(f,im.p^,im.size,n); { write image to disk }
close(f);
end;
procedure readimage(fn:string; var im:image);
{ There is no error checking as to how much memory is available. The
size of an image is approximately the number of pixels divided by
two (VGA mode). A good use of this procedure is to write a program that
draws a fairly complex image to be used in another program. Then, use
GrabImage to capture the smallest area containing the image you want
and WriteImage to save it to disk. Then use ReadImage and ShowImage to
draw the image in another program. That way the image doesn't have to be
drawn at run-time. }
var
f: file;
n: word;
begin
assign(f,fn);
reset(f,1);
im.size:=filesize(f); { assumes entire file is image }
getmem(im.p,im.size); { allocate space }
blockread(f,im.p^,im.size,n); { read in image }
close(f);
end;
procedure grabimage(x1,y1,x2,y2:word; var im:image);
{ This procedure captures the specified image into a buffer. It also
allocates enough memory, which can be released with KillImage. This
is very similar to GetImage, but I have hidden away the details and
memory (de)allocation to make the procedures more complementary. }
begin
im.size:=imagesize(x1,y1,x2,y2);
getmem(im.p,im.size);
getimage(x1,y1,x2,y2,im.p^)
end;
procedure showimage(x1,y1:word; var im:image; bitblt:word);
{ The only difference between this and PutImage is the programmer
specifies an image instead of a buffer. This helps to preserve
consistency. }
begin
putimage(x1,y1,im.p^,bitblt)
end;
procedure killimage(var im:image);
{ This procedure deallocates any memory used to store an image. }
begin
freemem(im.p,im.size);
im.size:=0;
end;
begin
europeanfont:=installuserfont('euro');
complexfont:=installuserfont('lcom');
triplexscriptfont:=installuserfont('tscr');
scriptfont:=installuserfont('scri');
simplefont:=installuserfont('simp');
end.